Shareware Grab Bag/Shareware Grab Bag.iso/007/cisb.arc/CISB.PAS

Pascal/Delphi Source File | 1985-06-09 | 20.3 KB | 718 lines

{***************
**
**  This module implements the B-Protocol Functions for terminal.pas.
**  The only procedures this routine requires that are not located here
**  are send and cgetc.  These routines should be as follows:
**
**  procedure send(ch : integer);
**  (*This procedure sends the character who's ordinal value is CH to the
**    async port*)
**
**  function cgetc(wait_time : integer) : integer;
**  (*This function waits approximately WAIT_TIME seconds for a character
**    at the async port.  If no character is received, -1 is returned,
**    otherwise the ordinal value of the received character is returned*)
**
**  These definitions should be sufficient to implement B-Protocol in a
**  pascal program.  The routine DO_TRANSFER should be invoked whenever a
**  ENQ (ascii value 5) is received from the host.  It returns TRUE if the
**  operation it performs is successful.
**
**  If you have any questions contact me, Jim Nutt, at either 76044,1155 or
**  71076,1434 on CIS, or at FIDOnet Node 452.
****************}

function do_transfer : boolean;

  const   xmt_size     = 511;
          rcv_size     = 512;
          max_errors   =  10;

{ Sender actions }

          s_send_packet  = 0;
          s_get_dle      = 1;
          s_get_num      = 2;
          s_get_seq      = 3;
          s_get_data     = 4;
          s_get_checksum = 5;
          s_timed_out    = 6;
          s_send_nak     = 7;

{ Receiver actions }

          r_get_dle      = 0;
          r_get_b        = 1;
          r_get_seq      = 2;
          r_get_data     = 3;
          r_get_checksum = 4;
          r_send_nak     = 5;
          r_send_ack     = 6;

{Other Constants}

          xmt_col = 50;
          rcv_col = 36;
          xon  = 17;
          xoff = 19;
          dle  = 16;
          etx  = 03;
          nak  = 21;
          enq  = 05;
          wack = 59;


  type lstr    = string[255];
       buffertype = array[0..520] of byte;
       bytefile = file of byte;

  var
    timer,
    r_size,                                { size of receiver buffer }
    checksum,
    seq_num,
    ch : integer;                               { current character }

    xoff_flag,
    timed_out,                                { we timed out before receiving character }
    masked : boolean;
    { true if ctrl character was 'masked' }

    s_buffer : buffertype;
    r_buffer : buffertype;
    filename : lstr;                        { pathname }
    i, n     : integer;
    dummy    : boolean;
    s_counter  : byte;
    r_counter  : byte;

procedure send_masked_byte(ch : integer);

begin
  if ch < 32
    then
      begin
        send(dle);
        send(ch + ord('@'));
      end
    else
      send(ch);
    s_counter := (s_counter + 1) mod 64;
    if s_counter = 0 then write('.');
end;

procedure send_ack;
begin
  write('!');
  send(dle);
  send(seq_num + ord('0'));
end;

procedure send_nak;
begin
  write('?');
  send(nak);
end;


procedure send_enq;
begin
  write('(');
  send(enq);
end;

function read_byte : boolean;

begin

  timed_out := false;

  ch := cgetc(timer);

  if ch < 0 then
    begin
    read_byte := false;
    exit;
    end;

  r_counter := (r_counter + 1) mod 64;
  if r_counter = 0 then write('+');
  read_byte :=  true;
end;


function read_masked_byte : boolean;

begin
  masked := false;

  if (read_byte = false)
    then begin
           read_masked_byte := false;
           exit;
      end;

  if (ch = dle)
    then
      begin
        if (read_byte = false)
          then begin
                 read_masked_byte := false;
                 exit;
            end;
        ch := ch and $1f;
        masked := true;
      end;

  read_masked_byte := true;
end;


procedure do_checksum(ch : integer);

begin
  checksum := checksum shl 1;
  if (checksum > 255)
    then checksum := (checksum and $ff) + 1;
  checksum := checksum + ch;
  if (checksum > 255)
    then checksum := (checksum and $ff) + 1;
end;

function send_packet(size: integer) : boolean;

var
  action,
  errors,
  next_seq,
  block_num,
  i : integer;
  sent_enq :     boolean;

begin

  next_seq := (seq_num + 1) mod 10;
  errors := 0;
  sent_enq := false;
  action := s_send_packet;
  writeln;

  while true do
    case (action) of
      s_send_packet: begin
                       checksum := 0;
                       send(dle);
                       send(ord('B'));
                       send(next_seq + ord('0'));
                       do_checksum(next_seq + ord('0'));

                       for i := 0 to  size do
                         begin
                           send_masked_byte(s_buffer[i]);
                           do_checksum(s_buffer[i]);
                         end;

                       send(etx);
                       do_checksum(etx);
                       send_masked_byte(checksum);
                       action := s_get_dle;
                     end;

      s_get_dle: begin
                   timer := 30;

                   if (read_byte = false)
                     then action := s_timed_out
                     else if (ch = dle)
                            then action := s_get_num
                            else if (ch = nak)
                                   then
                                     begin
                                       errors := errors + 1;
                                       if (errors > max_errors)
                                         then begin
                                                send_packet := false;
                                                exit;
                                           end;
                                       action := s_send_packet;
                                     end
                                   else if (ch = etx)
                                          then action := s_send_nak;

                 end;
      s_get_num: begin
                   timer := 30;

                   if (read_byte = false)
                     then action := s_timed_out
                     else if (ch >= ord('0')) and (ch <= ord('9'))
                            then
                              begin

                                if (ch - ord('0') = seq_num)
                                  then
                                    if (sent_enq)
                                      then action := s_send_packet
                                      else action := s_get_dle
                                  else
                                    if (ch - ord('0') = next_seq)
                                      then
                                        begin
                                          seq_num := next_seq;
                                          send_packet := true;
                                          exit
                                        end
                                      else
                                        if (errors = 0)
                                          then action := s_send_packet
                                          else action := s_get_dle;

                              end
                            else if (ch = nak)
                                   then action := s_send_packet
                                   else if (ch = wack)
                                          then
                                            begin
                                              timer := timer + 10;
                                              action := s_get_dle;
                                            end
                                          else if (ch = ord('B'))
                                                 then action := s_get_seq
                                                 else if (ch = etx)
                                                        then action := s_send_nak
                                                        else action := s_get_dle;
                 end;

      s_get_seq: begin
                   timer := 10;

                   if (read_byte = false)
                     then action := s_send_nak
                     else
                       begin
                         checksum := 0;
                         block_num := ch - ord('0');
                         do_checksum(ch);
                         i := 0;
                         action := s_get_data;
                       end;

                 end;
      s_get_data: begin
                    timer := 10;

                    if (read_masked_byte = false)
                      then action := s_send_nak
                      else if ((ch = etx) and not masked)
                             then
                               begin
                                 do_checksum(etx);
                                 action := s_get_checksum;
                               end
                             else
                               begin
                                 r_buffer[i] := ch;
                                 i := i + 1;
                                 do_checksum(ch);
                               end;

                  end;

      s_get_checksum: begin
                        timer := 10;

                        if (read_masked_byte = false)
                          then action := s_send_nak
                          else if (ch <> checksum)
                                 then action := s_send_nak
                                 else if (block_num <> (next_seq + 1) mod 10)
                                        then action := s_send_nak
                                        else
                                          begin
                                            seq_num := block_num;
                                            send_ack;
                                            r_size := i;
                                            send_packet :=  true;
                                            exit;
                                          end;

                      end;

      s_timed_out: begin
                     errors := errors + 1;
                     if (errors > 4)
                       then begin
                              send_packet := false;
                              exit;
                         end;
                     action := s_get_dle;
                   end;

      s_send_nak: begin
                    errors := errors + 1;
                    if (errors > max_errors)
                      then begin
                             send_packet := false;
                             exit;
                        end;
                    send_nak;
                    action := s_get_dle;
                  end;
    end;

end; { Send_Packet }


procedure send_failure(code : char);

var dummy : boolean;

begin
  s_buffer[0] := ord('F');
  s_buffer[1] := ord(code);
  dummy := send_packet(2);
end;


function read_file(var data_file : bytefile; var s_buffer : buffertype;
                   n, xmt_size : integer) : integer;

var i : integer;

begin
  i := n;
  while (not eof(data_file)) and (xmt_size > 0) do
    begin
      read(data_file,s_buffer[i]);
      i := i + 1;
      xmt_size := xmt_size - 1;
    end;
  read_file := i - n;
end;

function send_file(name : lstr) : boolean;

var n : integer;
  data_file : bytefile;

begin

  assign(data_file,name);
{$i-}
  reset(data_file);
{$i+}

  if (ioresult > 0)
    then
      begin
        send_failure('E');
        begin
          send_file := false;
          exit;
        end
      end;

  repeat
    s_buffer[0] := ord('N');
    n := read_file(data_file, s_buffer,1, xmt_size);

    if (n > 0)
      then
        begin

          if (send_packet(n) = false)
            then
              begin
                begin
                  send_file := false;
                  exit;
                end
              end;

        end;
  until not (n > 0);

{ Inform host that the file was sent }

  s_buffer[0] := ord('T');
  s_buffer[1] := ord('C');

  if (send_packet(2) = false)
    then
      begin
        begin
          send_file := false;
          exit;
        end
      end
    else
      begin
        close(data_file);
        send_file := true;
        exit;
      end;

end; { Send_File }

function read_packet : boolean;

{True if packet is available from host}

var
  action,
  next_seq,
  block_num,
  errors,
  i : integer;

begin
  fillchar(r_buffer,520,0);
  next_seq := (seq_num +  1) mod 10;
  errors := 0;
  action := r_get_dle;
  writeln;

  while true do
    begin
      timer := 10;

      case  (action) of
        r_get_dle: begin
                     if (read_byte = false)
                       then action := r_send_nak
                       else if ((ch and$7F) = dle)
                              then action := r_get_b
                              else if ((ch and $7F) = enq)
                                     then action := r_send_ack;
                   end;

        r_get_b: begin
                   if (read_byte = false)
                     then action := r_send_nak
                     else if ((ch and $7F) = ord('B'))
                            then action := r_get_seq
                            else if (ch = enq)
                                   then action := r_send_ack
                                   else action := r_get_dle;
                 end;

        r_get_seq: begin
                     if (read_byte = false)
                       then action := r_send_nak
                       else if (ch = enq)
                              then action := r_send_ack
                              else
                                begin
                                  checksum := 0;
                                  block_num := ch - ord('0');
                                  do_checksum(ch);
                                  i := 0;
                                  action := r_get_data;
                                end;

                   end;

        r_get_data: begin
                      if (read_masked_byte = false)
                        then action := r_send_nak
                        else if ((ch = etx) and not masked)
                               then
                                 begin
                                   do_checksum(etx);
                                   action := r_get_checksum;
                                 end
                               else
                                 begin
                                   r_buffer[i] := ch;
                                   i := i + 1;
                                   do_checksum(ch);
                                 end;

                    end;

        r_get_checksum: begin
                          if (read_masked_byte = false)
                            then action := r_send_nak
                            else if (ch <> checksum)
                                   then action := r_send_nak
                                   else if (block_num = seq_num)
                                          then
                                            begin
                                              if (r_buffer[0] = ord('F'))
                                                then
                                                  begin
                                                    seq_num := block_num;
                                                    r_size := i;
                                                    read_packet :=  true;
                                                    exit;
                                                  end
                                                else
                                                  action := r_send_ack;
                                            end
                                          else if (block_num <> next_seq)
                                                 then action := r_send_nak
                                                 else
                                                   begin
                                                     seq_num := block_num;
                                                     r_size := i;
                                                     read_packet :=  true;
                                                     exit;
                                                   end;

                        end;

        r_send_nak: begin
                      errors := errors + 1;
                      if (errors > max_errors)
                        then begin
                               read_packet := false;
                               exit;
                          end;
                      send_nak;
                      action := r_get_dle;
                    end;

        r_send_ack: begin
                      send_ack;
                      action := r_get_dle;        { wait for the next block }
                    end;
      end;
    end;

end; { Read_Packet }

function  write_file(var data_file : bytefile; r_buffer : buffertype;
                     n, size : integer) : integer;

var i : integer;

begin
  for i := 1 to size do
    write(data_file,r_buffer[n + i - 1]);
end;

function receive_file(name : lstr) : boolean;

var
  data_file : bytefile;
  status : integer;

begin

  assign(data_file,name);
{$i-}
  rewrite(data_file);
{$I+}

  if (ioresult > 0)
    then
      begin
        send_failure('E');
        begin
          receive_file := false;
          exit;
        end
      end;

  send_ack;

  while true do
    begin

      if (read_packet = true)
        then
          begin

            case chr(r_buffer[0]) of
              'N': begin
                     status := write_file(data_file,r_buffer,1,r_size - 1);
                     send_ack;
                   end;

              'T': begin
                     if r_buffer[1] = ord('C') then
                         begin
                           writeln('Transfer Complete');
                           close(data_file);
                           send_ack;
                           receive_file :=  true;
                           exit;
                         end;

                   end;

              'F': begin
                     send_ack;
                     receive_file := false;
                     exit;
                   end;

            end;

          end;

    end;

end; { Receive_File }

begin

  xoff_flag := false;
  r_counter := 0;
  s_counter := 0;
  seq_num := 0;
  send_ack;

  if (read_packet = true)
    then
      begin

        case chr(r_buffer[0]) of
          'T': begin
                 case chr(r_buffer[1]) of
                   'D' : write('Receiving ');
                   'U' : write('Sending ');
                   else
                     begin
                       send_failure('N');
                       exit;
                     end;
                 end;

                 case chr(r_buffer[2]) of
                   'A': write('ASCII file "');
                   'B': write('Binary file "');
                   else
                     begin
                       send_failure('N');        { not implemented }
                       do_transfer := false;
                       exit;
                     end;
                 end;

                 i := 2;
                 filename := '';

                 while (r_buffer[i] <> 0) and (i < r_size) do
                   begin
                   i := i + 1;
                   filename := filename + chr(r_buffer[i]);
                   end;

                 writeln(filename,'"');

                 if (r_buffer[1] = ord('U'))
                   then
                     dummy := send_file(filename)
                   else
                     dummy := receive_file(filename);

               end;
        end;
      end
    else
      writeln('Cannot receive initial packet, transfer aborted');

end; { Do_Transfer }